home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / SPADV.ZIP / IMED.PAS < prev    next >
Pascal/Delphi Source File  |  1994-03-17  |  11KB  |  454 lines
  1. program Image_Editor;
  2.  
  3. uses Crt,Graph,CGAdrv;
  4.  
  5. type
  6.   KeyType=array[1..2] of char;
  7.   ImageType=array[1..2610] of byte;
  8.   ScreenType=array[0..99,0..99] of byte;
  9.   DirectionType=(None,Up,Down,Left,Right);
  10.   Str255=string[255];
  11.   Str40=string[40];
  12.   ChrSet=set of char;
  13.  
  14. var
  15.   Palette,Ctr:word;
  16.   Key:KeyType;
  17.   Image:ImageType;
  18.   Screen:ScreenType;
  19.   FileName:Str40;
  20.   ImFile:file of byte;
  21.  
  22. procedure Count(var Ctr:integer; Incr,Low,High:integer);
  23. begin
  24.   Ctr:=Ctr+Incr;
  25.   if Ctr<Low then Ctr:=High;
  26.   if Ctr>High then Ctr:=Low;
  27. end;
  28.  
  29. procedure GetKeyPress(var Key:KeyType);
  30. begin
  31.   while KeyPressed do Key[1]:=ReadKey;
  32.   Key[1]:=UpCase(ReadKey);
  33.   if (Key[1]=#0) and KeyPressed then Key[2]:=ReadKey
  34.   else Key[2]:=#0
  35. end;
  36.  
  37. procedure KeyMove(Key:KeyType; var MovX,MovY:integer; Flip:boolean);
  38.   procedure Check(var Mov:integer);
  39.   begin
  40.     case Flip of
  41.       True:begin
  42.         if Mov<0 then Mov:=99;
  43.         if Mov>99 then Mov:=0;
  44.       end;
  45.       False:begin
  46.         if Mov<0 then Mov:=0;
  47.         if Mov>99 then Mov:=99;
  48.       end;
  49.     end;
  50.   end;
  51. begin
  52.   if Key[2] in [#71,#72,#73] then Dec(MovY); (*Count(MovY,-1,0,99);*)
  53.   if Key[2] in [#71,#75,#79] then Dec(MovX); (*Count(MovX,-1,0,99);*)
  54.   if Key[2] in [#73,#77,#81] then Inc(MovX); (*Count(MovX,+1,0,99);*)
  55.   if Key[2] in [#79,#80,#81] then Inc(MovY); (*Count(MovY,+1,0,99);*)
  56.   Check(MovX); Check(MovY);
  57. end;
  58.  
  59. function ChooseKey(Valid:ChrSet; var Key:KeyType):boolean;
  60. begin
  61.   repeat
  62.     GetKeyPress(Key);
  63.     Key[1]:=UpCase(Key[1]);
  64.   until Key[1] in (Valid+[#27]);
  65.   ChooseKey:=(Key[1]<>#27);
  66. end;
  67.  
  68. procedure ClearImageData;
  69. begin
  70.   FillChar(Image,SizeOf(Image),#0);
  71.   FillChar(Screen,SizeOf(Screen),#0);
  72. end;
  73.  
  74. procedure Initialise;
  75. var
  76.   Gd,Gm:integer;
  77. begin
  78.   ClearImageData;
  79.   Gd:=CGA; Gm:=CGAC1;
  80.   Palette:=Gm;
  81.     InitCGA(Palette);
  82. (*  InitGraph(Gd,Gm,'');*)
  83.   DirectVideo:=False;
  84.   SetColor(2);
  85.   Rectangle(201,0,319,199);
  86.   Rectangle(218,0,319,101);
  87.   Line(201,101,218,101);
  88.   SetTextStyle(DefaultFont,VertDir,1);
  89.   SetColor(3);
  90.   OutTextXY(214,2,'Image Editor');
  91.   SetTextStyle(DefaultFont,HorizDir,1);
  92.   for Ctr:=0 to 3 do begin
  93.     SetFillStyle(SolidFill,Ctr);
  94.     Bar(Ctr*29+203,190,(Ctr+1)*29+201,197);
  95.   end;
  96.   FileName:='';
  97. end;
  98.  
  99. procedure ImageEditor;
  100. var
  101.   Quit,Draw,Msg:boolean;
  102.   Cx,Cy,Color,
  103.   Px1,Py1,Px2,Py2:integer;
  104.  
  105.   procedure Message(Txt:Str255);
  106.   var
  107.     OutTxt:Str255;
  108.     TxtPos,Y:byte;
  109.   begin
  110.     SetFillStyle(SolidFill,0);
  111.     Bar(202,102,318,188);
  112.     SetTextJustify(CenterText,TopText);
  113.     OutTxt:='';
  114.     Y:=110; SetColor(3);
  115.     for TxtPos:=1 to Length(Txt) do begin
  116.       if Txt[TxtPos]<>'^' then OutTxt:=OutTxt+Txt[TxtPos];
  117.       if (Txt[TxtPos]='^') or (TxtPos=Length(Txt)) then begin
  118.         OutTextXY(262,Y,OutTxt);
  119.         Inc(Y,9);
  120.         OutTxt:='';
  121.       end;
  122.     end;
  123.     SetTextJustify(LeftText,TopText);
  124.     Msg:=(Txt<>'');
  125.   end;
  126.  
  127.   function Sure:boolean;
  128.   begin
  129.     Message('^^Are you sure?');
  130.     GetKeyPress(Key);
  131.     Sure:=(UpCase(Key[1])='Y');
  132.   end;
  133.  
  134.   function GetFileName:boolean;
  135.   var
  136.     Key:KeyType;
  137.     Keep:boolean;
  138.   begin
  139.     Message('^Enter^filename:^(max. 12 chrs)');
  140.     SetTextJustify(CenterText,TopText);
  141.     SetColor(3);
  142.     OutTextXY(262,152,FileName);
  143.     Keep:=True;
  144.     repeat
  145.       GetKeyPress(Key);
  146.       SetColor(0);
  147.       OutTextXY(262,152,FileName);
  148.       if (Key[1] in [' '..'~']) and (Length(FileName)<12) then begin
  149.         if Keep then begin
  150.           FileName:='';
  151.           Keep:=False;
  152.         end;
  153.         FileName:=FileName+Key[1]
  154.       end else if (Key[1]=#8) and (Length(FileName)>0) then
  155.         Dec(FileName[0]);
  156.       Keep:=False;
  157.       SetColor(3);
  158.       OutTextXY(262,152,FileName);
  159.     until Key[1] in [#13,#27];
  160.     SetTextJustify(LeftText,TopText);
  161.     GetFileName:=(FileName<>'') and (Key[1]=#13);
  162.   end;
  163.  
  164.   procedure ShowCursor;
  165.   var
  166.     x,y:integer;
  167.   begin
  168.     SetColor(3);
  169.     SetWriteMode(XORput);
  170.     x:=Cx*2-1; y:=Cy*2-1;
  171.     Line(x,y,x+3,y); Line(x+3,y+1,x+3,y+3);
  172.     Line(x+2,y+3,x,y+3); Line(x,y+2,x,y+1);
  173. (*    Rectangle(x,y,x+3,y+3);*)
  174.     SetWriteMode(NormalPut);
  175.   end;
  176.  
  177.   procedure ShowColor(Incr:integer);
  178.   begin
  179.     if Incr<>0 then begin
  180.       SetColor(0);
  181.       Rectangle(Color*29+202,189,(Color+1)*29+202,198);
  182.     end;
  183.     Count(Color,Incr,0,3);
  184.     SetColor(3);
  185.     Rectangle(Color*29+202,189,(Color+1)*29+202,198);
  186.   end;
  187.  
  188.   procedure ShowPixel(x,y:integer);
  189.   begin
  190.     SetColor(Screen[x,y]);
  191.     Rectangle(x*2,y*2,x*2+1,y*2+1);
  192.     PutPixel(219+x,1+y,Screen[x,y]);
  193.   end;
  194.  
  195.   procedure ImgPixel(x,y,Col:integer);
  196.   begin
  197.     if Screen[x,y]<>Col then begin
  198.       Screen[x,y]:=Col;
  199.       ShowPixel(x,y);
  200.     end;
  201.   end;
  202.  
  203.   function GetColor(var Col:integer):boolean;
  204.   var
  205.     Key:KeyType;
  206.   begin
  207.     repeat
  208.       GetKeyPress(Key);
  209.       if Key=#9#0  then ShowColor(+1);
  210.       if Key=#0#15 then ShowColor(-1);
  211.     until Key[1] in [#27,#13];
  212.     Col:=Color;
  213.     GetColor:=(Key[1]=#13);
  214.   end;
  215.  
  216.   procedure UpdateImage;
  217.   var
  218.     x,y,Col:integer;
  219.   begin
  220.     Message('^^Updating^image,^^please wait!');
  221.     for x:=0 to 99 do
  222.       for y:=0 to 99 do begin
  223.         Col:=GetPixel(x*2,y*2);
  224.         if Col<>Screen[x,y] then begin
  225.           Screen[x,y]:=Col;
  226.           PutPixel(219+x,1+y,Col);
  227.         end;
  228.       end;
  229.   end;
  230.  
  231.   procedure UpdateScreen;
  232.   var
  233.     x,y,Col:integer;
  234.   begin
  235.     Message('^^Updating^screen,^^please wait!');
  236.     for x:=0 to 99 do
  237.       for y:=0 to 99 do
  238.         ImgPixel(x,y,GetPixel(219+x,1+y));
  239.   end;
  240.  
  241.  
  242.   procedure FillArea(x,y:integer);
  243.   var
  244.     Key:KeyType;
  245.     Fcol,Bcol:integer;
  246.   begin
  247.     Message('^^Choose^^fill color:');
  248.     if not GetColor(Fcol) then Exit;
  249.     Message('^^Choose^^border color:');
  250.     if not GetColor(Bcol) then Exit;
  251.     SetViewPort(0,0,199,199,ClipOn);
  252.     SetFillStyle(SolidFill,FCol);
  253.     FloodFill(x*2,y*2,Bcol);
  254.     SetViewPort(0,0,319,199,ClipOn);
  255.     UpdateImage;
  256.   end;
  257.  
  258.   function ClearImage:boolean;
  259.   var
  260.     Key:KeyType;
  261.     DoIt:boolean;
  262.   begin
  263.     DoIt:=Sure;
  264.     if DoIt then begin
  265.       ClearImageData;
  266.       SetFillStyle(SolidFill,0);
  267.       Bar(0,0,199,199);
  268.       Bar(219,1,318,100);
  269.     end;
  270.     ClearImage:=DoIt;
  271.   end;
  272.  
  273.   procedure SaveImage;
  274.   var
  275.     Key:KeyType;
  276.     Ctr,Sx1,Sy1,Sx2,Sy2:integer;
  277.     MoveAll:boolean;
  278.  
  279.     procedure ShowPart;
  280.     begin
  281.       Rectangle(Px1*2,Py1*2,Px2*2+1,Py2*2+1);
  282.     end;
  283.  
  284.   begin
  285.     Message('^^W)hole or^P)artial?');
  286.     if not ChooseKey(['W','P'],Key) then Exit;
  287.     case Key[1] of
  288.       'W':begin
  289.         Sx1:=0; Sy1:=0; Sx2:=99; Sy2:=99;
  290.       end;
  291.       'P':begin
  292.         Message('^^Choose image^part to save.');
  293.         SetWriteMode(XORput);
  294.         SetLineStyle(DottedLn,0,1);
  295.         SetColor(1);
  296.         ShowPart;
  297.         MoveAll:=True;
  298.         repeat
  299.           GetKeyPress(Key);
  300.           ShowPart;
  301.           case Key[1] of
  302.             #9:MoveAll:=not MoveAll;
  303.             #0:begin
  304.               if MoveAll then KeyMove(Key,Px1,Py1,False);
  305.               KeyMove(Key,Px2,Py2,False);
  306.               if Px1=99 then Dec(Px1);
  307.               if Py1=99 then Dec(Py1);
  308.               if Px2=Px1 then Inc(Px2);
  309.               if Py2=Py1 then Inc(Py2);
  310.             end;
  311.           end;
  312.           ShowPart;
  313.         until Key[1] in [#13,#27];
  314.         ShowPart;
  315.         SetWriteMode(NormalPut);
  316.         SetLineStyle(SolidLn,0,1);
  317.         if Key[1]=#27 then Exit;
  318.         Sx1:=Px1; Sy1:=Py1; Sx2:=Px2; Sy2:=Py2;
  319.       end;
  320.     end;
  321.     GetImage(219+Sx1,1+Sy1,219+Sx2,1+Sy2,Image);
  322.     if not GetFileName then Exit;
  323.     Assign(ImFile,FileName);
  324.     ReWrite(ImFile);
  325.     for Ctr:=1 to ImageSize(Sx1,Sy1,Sx2,Sy2) do
  326.       Write(ImFile,Image[Ctr]);
  327.     Close(ImFile);
  328.   end;
  329.  
  330.   procedure LoadImage;
  331.   var
  332.     Key:KeyType;
  333.     Ctr,Xs,Ys:integer;
  334.   begin
  335.     if not GetFileName then Exit;
  336.     if ClearImage then begin
  337.       Assign(ImFile,FileName); {$I-}
  338.       Reset(ImFile);           {$I+}
  339.       if IOresult<>0 then begin
  340.         Message('^^File not^found!');
  341.         GetKeyPress(Key);
  342.         Exit;
  343.       end;
  344.       for Ctr:=1 to 4 do
  345.         Read(ImFile,Image[Ctr]);
  346.       Xs:=Image[1]+Image[2]*256;
  347.       Ys:=Image[3]+Image[4]*256;
  348.       for Ctr:=5 to ImageSize(0,0,Xs,Ys) do
  349.         Read(ImFile,Image[Ctr]);
  350.       Close(ImFile);
  351.       PutImage(268-Xs div 2,50-Ys div 2,Image,NormalPut);
  352.       UpdateScreen;
  353.     end;
  354.   end;
  355.  
  356.   procedure HorizFlip;
  357.   var
  358.     x,y,y1:integer;
  359.     Temp:byte;
  360.   begin
  361.     for y:=0 to 49 do begin
  362.       y1:=99-y;
  363.       for x:=0 to 99 do
  364.         if Screen[x,y]<>Screen[x,y1] then begin
  365.           Temp:=Screen[x,y];
  366.           ImgPixel(x,y,Screen[x,y1]);
  367.           ImgPixel(x,y1,Temp);
  368.         end;
  369.     end;
  370.   end;
  371.  
  372.   procedure VertFlip;
  373.   var
  374.     x,y,x1:integer;
  375.     Temp:byte;
  376.   begin
  377.     for x:=0 to 49 do begin
  378.       x1:=99-x;
  379.       for y:=0 to 99 do
  380.         if Screen[x,y]<>Screen[x1,y] then begin
  381.           Temp:=Screen[x,y];
  382.           ImgPixel(x,y,Screen[x1,y]);
  383.           ImgPixel(x1,y,Temp);
  384.         end;
  385.     end;
  386.   end;
  387.  
  388.   procedure Rotate;
  389.   var
  390.     x,y:integer;
  391.     Scr1:ScreenType;
  392.   begin
  393.     Scr1:=Screen;
  394.     for x:=0 to 99 do
  395.       for y:=0 to 99 do
  396.         ImgPixel(x,y,Scr1[y,99-x]);
  397.   end;
  398.  
  399. begin
  400.   Quit:=False;
  401.   Draw:=False;
  402.   Msg:=False;
  403.   Cx:=49; Cy:=49;
  404.   Color:=3;
  405.   Px1:=39; Py1:=39;
  406.   Px2:=59; Py2:=59;
  407.   ShowColor(0);
  408.   ShowCursor;
  409.   repeat
  410.     GetKeyPress(Key);
  411.     ShowCursor;
  412.     case Key[1] of
  413.       #0:case Key[2] of
  414.         #82:ImgPixel(Cx,Cy,Color);
  415.         #83:ImgPixel(Cx,Cy,0);
  416.         #15:ShowColor(-1)
  417.         else KeyMove(Key,Cx,Cy,True);
  418.       end;
  419.       #9:ShowColor(+1);
  420.       #13:begin
  421.         Draw:=not Draw;
  422.         SetColor(3*Ord(Draw));
  423.         OutTextXY(309,180,'D');
  424.       end;
  425.       '0','1','2','3':begin
  426.         ShowColor((Ord(Key[1])-48)-Color);
  427.         ImgPixel(Cx,Cy,Color);
  428.       end;
  429.       'C':if ClearIMage then;
  430.       'F':FillArea(Cx,Cy);
  431.       'H':HorizFlip;
  432.       'L':LoadImage;
  433.       'R':Rotate;
  434.       'S':SaveImage;
  435.       'V':VertFlip;
  436.       #27,'Q':Quit:=True;
  437.     end;
  438.     if Msg then Message('');
  439.     if Draw then ImgPixel(Cx,Cy,Color);
  440.     ShowCursor;
  441.   until Quit;
  442. end;
  443.  
  444. procedure ShutDown;
  445. begin
  446.   CloseGraph;
  447.   RestoreCrtMode;
  448. end;
  449.  
  450. begin
  451.   Initialise;
  452.   ImageEditor;
  453. (*  ShutDown;*)
  454. end.